home *** CD-ROM | disk | FTP | other *** search
/ Garden Fax: Fruits, Vegetables & Herbs / Garden Fax - Fruits, Vegetables & Herbs (1991)(CDTV Publishing)[!].iso / system / basicdemos / saveilbm (.txt) < prev    next >
AmigaBASIC Source Code  |  1978-01-06  |  9KB  |  353 lines
  1. REM - SaveILBM
  2. REM -  by Carolyn Scheppner  CBM  04/86
  3.  
  4. REM - This program saves a demo custom
  5. REM -  screen as an IFF ILBM file.
  6. REM -  (Graphicraft,Deluxe Paint, etc.)
  7.  
  8. REM - No icon is created for the file.
  9. REM -  If you need one, copy the .info
  10. REM -  file of a Graphicraft pic and
  11. REM -  call it filename.info
  12.  
  13. REM - Color cycling variables are
  14. REM -  saved as a Graphicraft CCRT
  15. REM -  chunk.  The program could be
  16. REM -  modified to save color cycling
  17. REM -  information as DPaint CRNG
  18. REM -  chunks.
  19.  
  20. REM - Requires exec, graphics and dos
  21. REM -  .bmaps (Use new ConvertFD)
  22. REM
  23.  
  24. Main:
  25.  
  26. PRINT "SaveILBM --- Saves a screen as an IFF ILBM file"
  27. PRINT 
  28. PRINT " This program creates a demo screen and saves it as an"
  29. PRINT "IFF ILBM pic file which can be loaded in Graphicraft,"
  30. PRINT "DPaint, or Images.  (For Images, add '.pic' to filename)"
  31. PRINT
  32. PRINT " Color cycling data is saved as a Graphicraft CCRT chunk."
  33. PRINT "No icon is created for the save file.  If you need one,"
  34. PRINT "copy the .info file of one of your paint package's pics"
  35. PRINT "and rename it to match the name of your saved pic file."
  36. PRINT:PRINT
  37.  
  38. DIM bPlane&(5), cTabSave%(32)
  39.  
  40. REM - Functions from dos.library                   
  41. DECLARE FUNCTION xOpen&  LIBRARY
  42. DECLARE FUNCTION xRead&  LIBRARY
  43. DECLARE FUNCTION xWrite& LIBRARY
  44. REM - xClose returns no value
  45.  
  46. REM - Functions from exec.library
  47. DECLARE FUNCTION AllocMem&() LIBRARY
  48. REM - FreeMem returns no value
  49.  
  50. PRINT:PRINT "Looking for bmaps ... ";
  51. LIBRARY "dos.library"
  52. LIBRARY "exec.library"
  53. LIBRARY "graphics.library"
  54. PRINT "found them."
  55.  
  56. PRINT:PRINT "ENTER FILESPEC:"
  57. PRINT "( Do not save if your disk has less than 41K free )"
  58. PRINT "( Enter <RETURN> for NO save file )"
  59. PRINT
  60. INPUT "FileSpec for ILBM save file";ILBMname$
  61. PRINT
  62.  
  63. REM  Custom Screen, some graphics
  64. w = 320: h = 200: d = 5
  65.  
  66. AvailRam& = FRE(-1)
  67. NeededRam& = ((w/8)*h*(d+1))+5000
  68. IF AvailRam& < NeededRam& THEN
  69.    PRINT "Not enough free ram"
  70.    GOTO Mcleanup2
  71. END IF   
  72.  
  73. SCREEN 2,w,h,d,1
  74. t$=" SaveILBM"
  75. WINDOW 2,t$,,7,2
  76. PALETTE 0,1,1,1
  77. PALETTE 1,0.2,0.4,0.8
  78.  
  79. REM - Get Screen structure addresses
  80. GOSUB GetScrAddrs
  81.  
  82. REM - Init color cycling variables
  83. REM - (Init to 0 for no cycling)
  84. REM - These variables must be initialized
  85. REM - because this version of SaveILBM
  86. REM - always saves a Graphicraft CCRT chunk
  87. ccrtDir%   = 1
  88. ccrtStart% = 1
  89. ccrtEnd%   = nColors% - 1
  90. ccrtSecs&  = 0
  91. ccrtMics&  = 2000
  92.  
  93. REM - Draw some lines to cycle  
  94. cReg = ccrtStart% 
  95. x = 20 
  96. FOR y = 0 TO 80
  97.      LINE (x,y)-(w-x-10,180-y),cReg,b
  98.      x = x + 1
  99.      cReg = cReg + 1: IF cReg > ccrtEnd% THEN cReg = ccrtStart%
  100. NEXT
  101.  
  102. REM - Demo color cycling
  103. REM - Save colors
  104. FOR kk = 0 TO nColors% -1
  105.    cTabSave%(kk) = PEEKW(colorTab&+(kk*2))   
  106. NEXT
  107.    
  108. REM - Cycle colors
  109. deSecs& = ccrtSecs& * 3000
  110. deMics& = ccrtMics& / 500
  111. cStart& = colorTab& + (2*ccrtStart%)
  112. cEnd&   = colorTab& + (2*ccrtEnd%)
  113. repeat  = 80
  114.  
  115. IF ccrtDir% = 1 THEN GOSUB Fcycle :ELSE GOSUB Bcycle
  116.  
  117. REM - Restore colors
  118. CALL LoadRGB4&(sViewPort&,VARPTR(cTabSave%(0)),nColors%)
  119.  
  120.  
  121. REM - Save screen as ILBM file
  122. IF (ILBMname$<>"") THEN
  123.    saveError$ = ""
  124.    GOSUB SaveILBM
  125. END IF
  126.  
  127. Mcleanup:
  128. FOR de = 1 TO 5000:NEXT
  129. WINDOW CLOSE 2
  130. SCREEN CLOSE 2
  131.  
  132. Mcleanup2:
  133. LIBRARY CLOSE
  134. IF saveError$ <> "" THEN PRINT saveError$
  135. END
  136.  
  137.  
  138. Fcycle:
  139. FOR kk = 0 TO repeat
  140.    cTemp% = PEEKW(cStart&)
  141.    FOR jj& = cStart& + 2 TO cEnd& STEP 2
  142.       POKEW(jj&-2), PEEKW(jj&)
  143.    NEXT
  144.    POKEW cEnd&, cTemp%
  145.    CALL LoadRGB4&(sViewPort&,colorTab&,nColors%)
  146.    FOR d1& = 0 TO deSecs&
  147.       FOR d2& = 0 TO deMics&:NEXT
  148.    NEXT   
  149. NEXT
  150. RETURN
  151.  
  152. Bcycle:   
  153. FOR kk = 0 TO repeat   
  154.    cTemp% = PEEKW(cEnd&)
  155.    FOR jj& = cEnd& - 2 TO cStart& STEP -2
  156.       POKEW(jj&+2), PEEKW(jj&)
  157.    NEXT
  158.    POKEW(cStart&) = cTemp%
  159.    CALL LoadRGB4&(sViewPort&,colorTab&,nColors%)
  160.    FOR d1& = 0 TO deSecs&
  161.       FOR d2& = 0 TO deMics&:NEXT
  162.    NEXT   
  163. NEXT
  164. RETURN
  165.  
  166.  
  167. SaveILBM:
  168. REM - Saves current window's screen
  169. REM -  as an IFF ILBM file with a
  170. REM -  Graphicraft CCRT cycling chunk.
  171. REM - Requires the following variables
  172. REM -  to have been initialized:
  173. REM -    ILBMname$ (ILBM filespec)
  174. REM - Also, cycling variables
  175. REM -    ccrtDir% (1,-1, or 0 = none)
  176. REM -    ccrtStart% (low cycle reg)
  177. REM -    ccrtEnd%   (high cycle reg)
  178. REM -    ccrtSecs&  (cycle time in seconds)
  179. REM -    ccrtMics&  (cycle time in microseconds)
  180. REM 
  181.  
  182.  
  183. REM - init variables
  184. f$ = ILBMname$
  185. fHandle& = 0
  186. mybuf& = 0
  187.  
  188. filename$ = f$ + CHR$(0)
  189. fHandle& = xOpen&(SADD(filename$),1006)
  190. IF fHandle& = 0 THEN
  191.    saveError$ = "Can't open output file"
  192.    GOTO Scleanup
  193. END IF
  194.  
  195. REM - Alloc ram for work buffers
  196. ClearPublic& = 65537
  197. mybufsize& = 120
  198. mybuf& = AllocMem&(mybufsize&,ClearPublic&)
  199. IF mybuf& = 0 THEN
  200.    saveError$ = "Can't alloc buffer"
  201.    GOTO Scleanup
  202. END IF
  203.  
  204. cbuf& = mybuf&
  205.  
  206. REM - Get addresses of screen structures
  207. GOSUB GetScrAddrs
  208.  
  209. zero& = 0
  210. pad%  = 0
  211. aspect% = &Ha0b
  212.  
  213. REM - Compute chunk sizes
  214. BMHDsize& = 20
  215. CMAPsize& = (2^scrDepth%) * 3
  216. CAMGsize& = 4
  217. CCRTsize& = 14
  218. BODYsize& = (scrWidth%/8) * scrHeight% * scrDepth%
  219. REM - FORMsize& = Chunk sizes + 8 bytes per Chunk header + "ILBM"
  220. FORMsize& = BMHDsize&+CMAPsize&+CAMGsize&+CCRTsize&+BODYsize&+44
  221.  
  222. REM - Write FORM header
  223. tt$ = "FORM"
  224. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  225. wLen& = xWrite&(fHandle&,VARPTR(FORMsize&),4)
  226. tt$ = "ILBM"
  227. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  228.  
  229. IF wLen& <= 0 THEN
  230.    saveError$ = "Error writing FORM header"
  231.    GOTO Scleanup
  232. END IF   
  233.  
  234. REM - Write out BMHD chunk
  235. tt$ = "BMHD"
  236. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  237. wLen& = xWrite&(fHandle&,VARPTR(BMHDsize&),4)
  238. wLen& = xWrite&(fHandle&,VARPTR(scrWidth%),2)
  239. wLen& = xWrite&(fHandle&,VARPTR(scrHeight%),2)
  240. wLen& = xWrite&(fHandle&,VARPTR(zero&),4)
  241. temp% = (256 * scrDepth%)
  242. wLen& = xWrite&(fHandle&,VARPTR(temp%),2)
  243. wLen& = xWrite&(fHandle&,VARPTR(zero&),4)
  244. wLen& = xWrite&(fHandle&,VARPTR(aspect%),2)
  245. wLen& = xWrite&(fHandle&,VARPTR(scrWidth%),2)
  246. wLen& = xWrite&(fHandle&,VARPTR(scrHeight%),2)
  247.  
  248. IF wLen& <= 0 THEN
  249.    saveError$ = "Error writing BMHD"
  250.    GOTO Scleanup
  251. END IF   
  252.  
  253. REM - Write CMAP chunk
  254. tt$ = "CMAP"
  255. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  256. wLen& = xWrite&(fHandle&,VARPTR(CMAPsize&),4)
  257.  
  258. REM - Build IFF ColorMap
  259. FOR kk = 0 TO nColors% - 1
  260.    regTemp% = PEEKW(colorTab& + (2*kk))
  261.    POKE(cbuf&+(kk*3)),(regTemp% AND &Hf00) / 16
  262.    POKE(cbuf&+(kk*3)+1),(regTemp% AND &Hf0) 
  263.    POKE(cbuf&+(kk*3)+2),(regTemp% AND &Hf) * 16
  264. NEXT
  265.  
  266. wLen& = xWrite&(fHandle&,cbuf&,CMAPsize&)
  267.  
  268. IF wLen& <= 0 THEN
  269.    saveError$ = "Error writing CMAP"
  270.    GOTO Scleanup
  271. END IF   
  272.  
  273. REM - Write CAMG chunk
  274. tt$ = "CAMG"
  275. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  276. wLen& = xWrite&(fHandle&,VARPTR(CAMGsize&),4)
  277. vpModes& = PEEKW(sViewPort& + 32)
  278. wLen& = xWrite&(fHandle&,VARPTR(vpModes&),4)
  279.  
  280. IF wLen& <= 0 THEN
  281.    saveError$ = "Error writing CAMG"
  282.    GOTO Scleanup
  283. END IF   
  284.  
  285.  
  286. REM - Write CCRT chunk
  287. tt$ = "CCRT"
  288. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  289. wLen& = xWrite&(fHandle&,VARPTR(CCRTsize&),4)
  290. wLen& = xWrite&(fHandle&,VARPTR(ccrtDir%),2)
  291. temp% = (256*ccrtStart%) + ccrtEnd%
  292. wLen& = xWrite&(fHandle&,VARPTR(temp%),2)
  293. wLen& = xWrite&(fHandle&,VARPTR(ccrtSecs&),4)
  294. wLen& = xWrite&(fHandle&,VARPTR(ccrtMics&),4)
  295. wLen& = xWrite&(fHandle&,VARPTR(pad%),2)
  296.  
  297. IF wLen& <= 0 THEN
  298.    saveError$ = "Error writing CCRT"
  299.    GOTO Scleanup
  300. END IF   
  301.  
  302.  
  303. REM - Write BODY chunk
  304. tt$ = "BODY"
  305. wLen& = xWrite&(fHandle&,SADD(tt$),4)
  306. wLen& = xWrite&(fHandle&,VARPTR(BODYsize&),4)
  307.  
  308. scrRowBytes% = scrWidth% / 8
  309. FOR rr = 0 TO scrHeight% -1
  310.    FOR pp = 0 TO scrDepth% -1
  311.       scrRow& = bPlane&(pp)+(rr*scrRowBytes%)
  312.       wLen& = xWrite&(fHandle&,scrRow&,scrRowBytes%)   
  313.       IF wLen& <= 0 THEN
  314.          saveError$ = "Error writing BODY"
  315.          GOTO Scleanup
  316.       END IF   
  317.    NEXT
  318. NEXT
  319.  
  320.    
  321. saveError$ = ""
  322.  
  323. Scleanup:
  324. IF fHandle& <> 0 THEN CALL xClose&(fHandle&)
  325. IF mybuf& <> 0 THEN CALL FreeMem&(mybuf&,mybufsize&)
  326. RETURN
  327.  
  328.  
  329.  
  330. GetScrAddrs:
  331. REM - Get addresses of screen structures
  332.    sWindow&   = WINDOW(7)
  333.    sScreen&   = PEEKL(sWindow& + 46)
  334.    sViewPort& = sScreen& + 44
  335.    sRastPort& = sScreen& + 84
  336.    sColorMap& = PEEKL(sViewPort& + 4)
  337.    colorTab&  = PEEKL(sColorMap& + 4)
  338.    sBitMap&   = PEEKL(sRastPort& + 4)
  339.  
  340.    REM - Get screen parameters
  341.    scrWidth%  = PEEKW(sScreen& + 12)
  342.    scrHeight% = PEEKW(sScreen& + 14)
  343.    scrDepth%  = PEEK(sBitMap& + 5)
  344.    nColors%   = 2^scrDepth%
  345.  
  346.    REM - Get addresses of Bit Planes 
  347.    FOR kk = 0 TO scrDepth% - 1
  348.       bPlane&(kk) = PEEKL(sBitMap&+8+(kk*4))
  349.    NEXT
  350. RETURN
  351.  
  352.  
  353.